Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/sharware/backup/backup.pas

Pascal/Delphi Source File | 1995-11-22 | 7.8 KB | 315 lines

{
 Designer: Craig Ward, [e-mail]
 Date:     22/11/95
 Version:  3.0


 Function: Backup dialog DLL. User specificies the source and destination directories,
           then the dialog will copy all files.


 Calling:  NOTE THAT THERE IS A CHANGE IN CALLING THIS DLL. The new call is:

            procedure ShowBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; iCompat: longint); far;
            external 'back';


 Update:   The DLL now copies files using a completely different routine (the
           previous routine used the WinAPI function LZCopy, which though so easy
           to use, it had the drawback that it would expand files that had been
           compressed using the Microsoft compression utility - clearly it's
           meant for setup routines).

           Other changes are purely cosmetic, though there is the significant
           addition of confirmation when over-writing existing files.

           Also, there are two additions to the parameters passed in calling the DLL.
           Neither of these are used at present, so the new pChar parameter can be set
           to nil, and the new longint parameter set to zero.
*********************************************************************************}
unit Backup;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, FileCtrl, Gauges, ExtCtrls;

type
  TBackupDlg = class(TForm)
    DirList: TDirectoryListBox;
    FList: TFileListBox;
    Label1: TLabel;
    lblSource: TLabel;
    Label2: TLabel;
    lblDestination: TLabel;
    btnOK: TBitBtn;
    btnCancel: TBitBtn;
    Panel1: TPanel;
    Gauge1: TGauge;
    BitBtn1: TBitBtn;
    driveBox: TDriveComboBox;
    Bevel1: TBevel;
    Bevel2: TBevel;
    SpeedButton1: TSpeedButton;
    Bevel3: TBevel;
    Bevel4: TBevel;
    procedure btnCancelClick(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure btnOKKeyPress(Sender: TObject; var Key: Char);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private declarations }
    procedure SetUpFiles;
    procedure CustCopyFiles(sSrce, sDest: string;iNum: integer);
  public
    { Public declarations }
  end;

var
  BackupDlg: TBackupDlg;
  iHlp: integer;

const
 iHelp: integer = 105; {help-context for SelectDirectory Dialog}


{exported procedure}
procedure ShowBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; iCompat: longint); export;

implementation

{$R *.DFM}
{***Exported Procedure**********************************************************}
procedure ShowBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; iCompat: longint);
begin
 {create dialog}
 try
  BackupDlg := TBackupDlg.Create(application);

  {set environment}
  if Assigned(pSource) then
   BackupDlg.lblSource.Caption := strPAS(pSource);
  if Assigned(pDestination) then
   BackupDlg.lblDestination.Caption := strPAS(pDestination);
  if Assigned(pHelp) then
   Application.HelpFile := strPAS(pHelp);

  {check directories}
  if directoryExists(backupDlg.lblSource.caption) then
   begin
    BackupDlg.FList.Directory := BackupDlg.lblSource.caption;
    BackupDlg.DirList.Directory := BackupDlg.lblSource.Caption;
    BackupDlg.DriveBox.Drive := BackupDlg.DirList.Drive;
   end
  else
    messageDlg('Source Directory not found.',mtWarning,[mbOK],0);
  if not directoryExists(backupDlg.lblDestination.caption) then
   messageDlg('Destination Directory not found.',mtWarning,[mbOK],0);

  BackupDlg.ShowModal;
 finally
  BackupDlg.Free;
 end;
end;

{***Buttons*********************************************************************}
{help}
procedure TBackupDlg.BitBtn1Click(Sender: TObject);
begin
 Application.HelpCommand(HELP_CONTEXT,BackupDlg.HelpContext);
end;


{close}
procedure TBackupDlg.btnCancelClick(Sender: TObject);
begin
 close;
end;

{copy}
procedure TBackupDlg.btnOKClick(Sender: TObject);
begin
 SetUpFiles;
end;

{Select Directory}
procedure TBackupDlg.SpeedButton1Click(Sender: TObject);
var
 sDir: string;
begin
 sDir := lblDestination.Caption;
 if SelectDirectory(sDir,[sdAllowCreate,sdPerformCreate,sdPrompt],iHelp) then
  lblDestination.caption := sDir;
end;


{***Copy procs******************************************************************}

{setup copying}
procedure TBackupDlg.SetUpFiles;
var
 OkToAll: boolean;
 iNum,iGauge: integer;
 sSrce, sDest: ^string;
begin
 try
  New(sSrce);
  New(sDest);

  {initialise}
  OkToAll := false;
  iNum := 0;
  iGauge := 0;

 {ensure that source directory exists}
 if not directoryExists(lblSource.caption) then
  begin
   messageDlg('Source Directory not found.',mtWarning,[mbOK],0);
   exit;
  end;

 {ensure that destination directory exists}
 if not directoryExists(lblDestination.caption) then
  begin
   messageDlg('Destination Directory not found.',mtWarning,[mbOK],0);
   exit;
  end;

 {check that the user is not trying to copy over source files}
 if CompareStr(lblSource.Caption,lblDestination.Caption) = 0 then
  begin
   messageDlg('Can not overwrite source files.',mtWarning,[mbOK],0);
   exit;
  end;

 {ensure that there are items in the file-list box}
 if (FList.Items.Count) = 0 then
  begin
   messageDlg('No files to be copied.',mtWarning,[mbOK],0);
   exit;
  end;


 {now, safe to continue with copy...}

 {calc progress to add to gauge}
 iGauge := 100 div (FList.Items.Count);
 Panel1.Visible := True;

 {init for loop}
 for iNum := 0 to (FList.Items.Count -1) do
  begin

  sSrce^ := lblSource.caption + '\' + (ExtractFileName(FList.Items.Strings[iNum]));
  sDest^ := lblDestination.caption + '\' + (ExtractFileName(FList.Items.Strings[iNum]));

 {check to see if file exists}
 if not OkToAll then
  begin
  if FileExists(sDest^) then
   begin
    case messageDlg('Overwrite '+sDest^,mtConfirmation,[mbYes,mbAll,mbNo],0) of

      idYes:
       custCopyFiles(sSrce^,sDest^,iNum);

      (idNo+1): {mrAll}
       begin
        OkToAll := true;
        custCopyFiles(sSrce^,sDest^,iNum);
       end;

      idNo:
       {do nothing}

    end;
   end
  else
   {file doesn't already exist - so copy}
   custCopyFiles(sSrce^,sDest^,iNum);
  end
  else
   {file does already exist, but overwrite is true}
   custCopyFiles(sSrce^,sDest^,iNum);

  {update gauge}
   Gauge1.AddProgress(iGauge);
   Application.ProcessMessages;

  end;

 {cleanup}
 Panel1.Visible := False;
 Gauge1.Progress := 0;
 OkToAll := false;

 finally
  Dispose(sSrce);
  Dispose(sDest);
 end;

end;


{copy routine}
procedure TBackupDlg.CustCopyFiles(sSrce,sDest: string;iNum: integer);
var
 fSrce, fDest: file;
 wRead, wWritten: word;
 p: array[1..2048] of char;
begin

  {initialise}
  wRead := 0;
  wWritten := 0;

  {assign and open files}
  AssignFile(fSrce,sSrce);
  AssignFile(fDest,sDest);

  {$I-}
  Reset(fSrce,1);
  {$I+}
  if IOResult <> 0  then
   begin
    messageDlg('Could not open: '+sSrce,mtWarning,[mbOK],0);
    exit;
   end;

  {$I-}
  Rewrite(fDest, 1);
  {$I+}
  if IOResult <> 0  then
   begin
    messageDlg('Could not create: '+sDest,mtWarning,[mbOK],0);
    exit;
   end;

  {copy loop}
  repeat
   BlockRead(fSrce, p, SizeOf(p), wRead);
   BlockWrite(fDest, p, wRead, wWritten);
  until (wRead = 0) or (wWritten <> wRead);

 {clean up}
 System.CloseFile(fSrce);
 System.CloseFile(fDest);

end;


{***Designer's signature***********************************************}
procedure TBackupDlg.btnOKKeyPress(Sender: TObject; var Key: Char);
begin
 if Key = ^J then
  messageDlg('This was designed by Craig Ward. Craig Ward can be reached'+
             ' at [e-mail]',mtInformation,[mbOK],0);
end;

{}
end.